home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / Math / BigInt.pm < prev    next >
Encoding:
Perl POD Document  |  1999-12-28  |  9.5 KB  |  375 lines
  1. package Math::BigInt;
  2.  
  3. use overload
  4. '+'    =>    sub {new Math::BigInt &badd},
  5. '-'    =>    sub {new Math::BigInt
  6.                $_[2]? bsub($_[1],${$_[0]}) : bsub(${$_[0]},$_[1])},
  7. '<=>'    =>    sub {new Math::BigInt
  8.                $_[2]? bcmp($_[1],${$_[0]}) : bcmp(${$_[0]},$_[1])},
  9. 'cmp'    =>    sub {new Math::BigInt
  10.                $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])},
  11. '*'    =>    sub {new Math::BigInt &bmul},
  12. '/'    =>    sub {new Math::BigInt 
  13.                $_[2]? scalar bdiv($_[1],${$_[0]}) :
  14.              scalar bdiv(${$_[0]},$_[1])},
  15. '%'    =>    sub {new Math::BigInt
  16.                $_[2]? bmod($_[1],${$_[0]}) : bmod(${$_[0]},$_[1])},
  17. '**'    =>    sub {new Math::BigInt
  18.                $_[2]? bpow($_[1],${$_[0]}) : bpow(${$_[0]},$_[1])},
  19. 'neg'    =>    sub {new Math::BigInt &bneg},
  20. 'abs'    =>    sub {new Math::BigInt &babs},
  21.  
  22. qw(
  23. ""    stringify
  24. 0+    numify)            # Order of arguments unsignificant
  25. ;
  26.  
  27. $NaNOK=1;
  28.  
  29. sub new {
  30.   my($class) = shift;
  31.   my($foo) = bnorm(shift);
  32.   die "Not a number initialized to Math::BigInt" if !$NaNOK && $foo eq "NaN";
  33.   bless \$foo, $class;
  34. }
  35. sub stringify { "${$_[0]}" }
  36. sub numify { 0 + "${$_[0]}" }    # Not needed, additional overhead
  37.  
  38. $zero = 0;
  39.  
  40.  
  41.  
  42. sub bnorm { #(num_str) return num_str
  43.     local($_) = @_;
  44.     s/\s+//g;                           # strip white space
  45.     if (s/^([+-]?)0*(\d+)$/$1$2/) {     # test if number
  46.     substr($_,$[,0) = '+' unless $1; # Add missing sign
  47.     s/^-0/+0/;
  48.     $_;
  49.     } else {
  50.     'NaN';
  51.     }
  52. }
  53.  
  54. sub internal { #(num_str) return int_num_array
  55.     local($d) = @_;
  56.     ($is,$il) = (substr($d,$[,1),length($d)-2);
  57.     substr($d,$[,1) = '';
  58.     ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d)));
  59. }
  60.  
  61. sub external { #(int_num_array) return num_str
  62.     $es = shift;
  63.     grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_);   # zero pad
  64.     &bnorm(join('', $es, reverse(@_)));    # reverse concat and normalize
  65. }
  66.  
  67. sub bneg { #(num_str) return num_str
  68.     local($_) = &bnorm(@_);
  69.     vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0';
  70.     s/^H/N/;
  71.     $_;
  72. }
  73.  
  74. sub babs { #(num_str) return num_str
  75.     &abs(&bnorm(@_));
  76. }
  77.  
  78. sub abs { # post-normalized abs for internal use
  79.     local($_) = @_;
  80.     s/^-/+/;
  81.     $_;
  82. }
  83.  
  84. sub bcmp { #(num_str, num_str) return cond_code
  85.     local($x,$y) = (&bnorm($_[$[]),&bnorm($_[$[+1]));
  86.     if ($x eq 'NaN') {
  87.     undef;
  88.     } elsif ($y eq 'NaN') {
  89.     undef;
  90.     } else {
  91.     &cmp($x,$y);
  92.     }
  93. }
  94.  
  95. sub cmp { # post-normalized compare for internal use
  96.     local($cx, $cy) = @_;
  97.     
  98.     return 0 if ($cx eq $cy);
  99.  
  100.     local($sx, $sy) = (substr($cx, 0, 1), substr($cy, 0, 1));
  101.     local($ld);
  102.  
  103.     if ($sx eq '+') {
  104.       return  1 if ($sy eq '-' || $cy eq '+0');
  105.       $ld = length($cx) - length($cy);
  106.       return $ld if ($ld);
  107.       return $cx cmp $cy;
  108.     } else { # $sx eq '-'
  109.       return -1 if ($sy eq '+');
  110.       $ld = length($cy) - length($cx);
  111.       return $ld if ($ld);
  112.       return $cy cmp $cx;
  113.     }
  114. }
  115.  
  116. sub badd { #(num_str, num_str) return num_str
  117.     local(*x, *y); ($x, $y) = (&bnorm($_[$[]),&bnorm($_[$[+1]));
  118.     if ($x eq 'NaN') {
  119.     'NaN';
  120.     } elsif ($y eq 'NaN') {
  121.     'NaN';
  122.     } else {
  123.     @x = &internal($x);             # convert to internal form
  124.     @y = &internal($y);
  125.     local($sx, $sy) = (shift @x, shift @y); # get signs
  126.     if ($sx eq $sy) {
  127.         &external($sx, &add(*x, *y)); # if same sign add
  128.     } else {
  129.         ($x, $y) = (&abs($x),&abs($y)); # make abs
  130.         if (&cmp($y,$x) > 0) {
  131.         &external($sy, &sub(*y, *x));
  132.         } else {
  133.         &external($sx, &sub(*x, *y));
  134.         }
  135.     }
  136.     }
  137. }
  138.  
  139. sub bsub { #(num_str, num_str) return num_str
  140.     &badd($_[$[],&bneg($_[$[+1]));    
  141. }
  142.  
  143. sub bgcd { #(num_str, num_str) return num_str
  144.     local($x,$y) = (&bnorm($_[$[]),&bnorm($_[$[+1]));
  145.     if ($x eq 'NaN' || $y eq 'NaN') {
  146.     'NaN';
  147.     } else {
  148.     ($x, $y) = ($y,&bmod($x,$y)) while $y ne '+0';
  149.     $x;
  150.     }
  151. }
  152.  
  153. sub add { #(int_num_array, int_num_array) return int_num_array
  154.     local(*x, *y) = @_;
  155.     $car = 0;
  156.     for $x (@x) {
  157.     last unless @y || $car;
  158.     $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0;
  159.     }
  160.     for $y (@y) {
  161.     last unless $car;
  162.     $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0;
  163.     }
  164.     (@x, @y, $car);
  165. }
  166.  
  167. sub sub { #(int_num_array, int_num_array) return int_num_array
  168.     local(*sx, *sy) = @_;
  169.     $bar = 0;
  170.     for $sx (@sx) {
  171.     last unless @y || $bar;
  172.     $sx += 1e5 if $bar = (($sx -= shift(@sy) + $bar) < 0);
  173.     }
  174.     @sx;
  175. }
  176.  
  177. sub bmul { #(num_str, num_str) return num_str
  178.     local(*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1]));
  179.     if ($x eq 'NaN') {
  180.     'NaN';
  181.     } elsif ($y eq 'NaN') {
  182.     'NaN';
  183.     } else {
  184.     @x = &internal($x);
  185.     @y = &internal($y);
  186.     &external(&mul(*x,*y));
  187.     }
  188. }
  189.  
  190. sub mul { #(*int_num_array, *int_num_array) return int_num_array
  191.     local(*x, *y) = (shift, shift);
  192.     local($signr) = (shift @x ne shift @y) ? '-' : '+';
  193.     @prod = ();
  194.     for $x (@x) {
  195.       ($car, $cty) = (0, $[);
  196.       for $y (@y) {
  197.     $prod = $x * $y + ($prod[$cty] || 0) + $car;
  198.     $prod[$cty++] =
  199.       $prod - ($car = int($prod * 1e-5)) * 1e5;
  200.       }
  201.       $prod[$cty] += $car if $car;
  202.       $x = shift @prod;
  203.     }
  204.     ($signr, @x, @prod);
  205. }
  206.  
  207. sub bmod { #(num_str, num_str) return num_str
  208.     (&bdiv(@_))[$[+1];
  209. }
  210.  
  211. sub bdiv { #(dividend: num_str, divisor: num_str) return num_str
  212.     local (*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1]));
  213.     return wantarray ? ('NaN','NaN') : 'NaN'
  214.     if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0');
  215.     return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0);
  216.     @x = &internal($x); @y = &internal($y);
  217.     $srem = $y[$[];
  218.     $sr = (shift @x ne shift @y) ? '-' : '+';
  219.     $car = $bar = $prd = 0;
  220.     if (($dd = int(1e5/($y[$#y]+1))) != 1) {
  221.     for $x (@x) {
  222.         $x = $x * $dd + $car;
  223.         $x -= ($car = int($x * 1e-5)) * 1e5;
  224.     }
  225.     push(@x, $car); $car = 0;
  226.     for $y (@y) {
  227.         $y = $y * $dd + $car;
  228.         $y -= ($car = int($y * 1e-5)) * 1e5;
  229.     }
  230.     }
  231.     else {
  232.     push(@x, 0);
  233.     }
  234.     @q = (); ($v2,$v1) = @y[-2,-1];
  235.     while ($#x > $#y) {
  236.     ($u2,$u1,$u0) = @x[-3..-1];
  237.     $q = (($u0 == $v1) ? 99999 : int(($u0*1e5+$u1)/$v1));
  238.     --$q while ($v2*$q > ($u0*1e5+$u1-$q*$v1)*1e5+$u2);
  239.     if ($q) {
  240.         ($car, $bar) = (0,0);
  241.         for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) {
  242.         $prd = $q * $y[$y] + $car;
  243.         $prd -= ($car = int($prd * 1e-5)) * 1e5;
  244.         $x[$x] += 1e5 if ($bar = (($x[$x] -= $prd + $bar) < 0));
  245.         }
  246.         if ($x[$#x] < $car + $bar) {
  247.         $car = 0; --$q;
  248.         for ($y = $[, $x = $#x-$#y+$[-1; $y <= $#y; ++$y,++$x) {
  249.             $x[$x] -= 1e5
  250.             if ($car = (($x[$x] += $y[$y] + $car) > 1e5));
  251.         }
  252.         }   
  253.     }
  254.     pop(@x); unshift(@q, $q);
  255.     }
  256.     if (wantarray) {
  257.     @d = ();
  258.     if ($dd != 1) {
  259.         $car = 0;
  260.         for $x (reverse @x) {
  261.         $prd = $car * 1e5 + $x;
  262.         $car = $prd - ($tmp = int($prd / $dd)) * $dd;
  263.         unshift(@d, $tmp);
  264.         }
  265.     }
  266.     else {
  267.         @d = @x;
  268.     }
  269.     (&external($sr, @q), &external($srem, @d, $zero));
  270.     } else {
  271.     &external($sr, @q);
  272.     }
  273. }
  274.  
  275. sub bpow { #(num_str, num_str) return num_str
  276.     local(*x, *y); ($x, $y) = (&bnorm($_[$[]), &bnorm($_[$[+1]));
  277.     if ($x eq 'NaN') {
  278.     'NaN';
  279.     } elsif ($y eq 'NaN') {
  280.     'NaN';
  281.     } elsif ($x eq '+1') {
  282.     '+1';
  283.     } elsif ($x eq '-1') {
  284.     &bmod($x,2) ? '-1': '+1';
  285.     } elsif ($y =~ /^-/) {
  286.     'NaN';
  287.     } elsif ($x eq '+0' && $y eq '+0') {
  288.     'NaN';
  289.     } else {
  290.     @x = &internal($x);
  291.     local(@pow2)=@x;
  292.     local(@pow)=&internal("+1");
  293.     local($y1,$res,@tmp1,@tmp2)=(1); # need tmp to send to mul
  294.     while ($y ne '+0') {
  295.       ($y,$res)=&bdiv($y,2);
  296.       if ($res ne '+0') {@tmp=@pow2; @pow=&mul(*pow,*tmp);}
  297.       if ($y ne '+0') {@tmp=@pow2;@pow2=&mul(*pow2,*tmp);}
  298.     }
  299.     &external(@pow);
  300.     }
  301. }
  302.  
  303. 1;
  304. __END__
  305.  
  306. =head1 NAME
  307.  
  308. Math::BigInt - Arbitrary size integer math package
  309.  
  310. =head1 SYNOPSIS
  311.  
  312.   use Math::BigInt;
  313.   $i = Math::BigInt->new($string);
  314.  
  315.   $i->bneg return BINT               negation
  316.   $i->babs return BINT               absolute value
  317.   $i->bcmp(BINT) return CODE         compare numbers (undef,<0,=0,>0)
  318.   $i->badd(BINT) return BINT         addition
  319.   $i->bsub(BINT) return BINT         subtraction
  320.   $i->bmul(BINT) return BINT         multiplication
  321.   $i->bdiv(BINT) return (BINT,BINT)  division (quo,rem) just quo if scalar
  322.   $i->bmod(BINT) return BINT         modulus
  323.   $i->bgcd(BINT) return BINT         greatest common divisor
  324.   $i->bnorm return BINT              normalization
  325.  
  326. =head1 DESCRIPTION
  327.  
  328. All basic math operations are overloaded if you declare your big
  329. integers as
  330.  
  331.   $i = new Math::BigInt '123 456 789 123 456 789';
  332.  
  333.  
  334. =over 2
  335.  
  336. =item Canonical notation
  337.  
  338. Big integer value are strings of the form C</^[+-]\d+$/> with leading
  339. zeros suppressed.
  340.  
  341. =item Input
  342.  
  343. Input values to these routines may be strings of the form
  344. C</^\s*[+-]?[\d\s]+$/>.
  345.  
  346. =item Output
  347.  
  348. Output values always always in canonical form
  349.  
  350. =back
  351.  
  352. Actual math is done in an internal format consisting of an array
  353. whose first element is the sign (/^[+-]$/) and whose remaining 
  354. elements are base 100000 digits with the least significant digit first.
  355. The string 'NaN' is used to represent the result when input arguments 
  356. are not numbers, as well as the result of dividing by zero.
  357.  
  358. =head1 EXAMPLES
  359.  
  360.    '+0'                            canonical zero value
  361.    '   -123 123 123'               canonical value '-123123123'
  362.    '1 23 456 7890'                 canonical value '+1234567890'
  363.  
  364.  
  365. =head1 BUGS
  366.  
  367. The current version of this module is a preliminary version of the
  368. real thing that is currently (as of perl5.002) under development.
  369.  
  370. =head1 AUTHOR
  371.  
  372. Mark Biggar, overloaded interface by Ilya Zakharevich.
  373.  
  374. =cut
  375.